home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / examples.zoo / misc / heapsort.lsp < prev    next >
Encoding:
Lisp/Scheme  |  1991-10-22  |  2.0 KB  |  51 lines
  1. ; Eine Sortierfunktion, sortiert eine Liste.
  2. ; Für list destruktiv.
  3. ; comparefun realisiert eine Totalordnung: -1 oder 0 oder +1 als Ergebnis.
  4. ; Dabei gelten zwei Listenelemente als gleich, wenn comparefun 0 liefert.
  5. (defun sort-list (list comparefun &key (key #'identity))
  6.   ; Methode: Heapsort.
  7.   ; Ein Array A[0..n-1], bei dem stets A[k]>=A[2k+1] und A[k]>=A[2k+2] gilt,
  8.   ; heißt "Heap".
  9.   (let* ((A (coerce list 'simple-vector))
  10.          (n (length A)))
  11.     (macrolet ((adjust (m n)
  12.                  ; Sei A[m+1..n-1] in Heap-Form. Danach ist auch A[m..n-1]
  13.                  ; in Heap-Form. Maximal O(log n) Operationen.
  14.                  `(let* ((j ,m) k)
  15.                     (loop
  16.                       (setq k (+ j j 1))
  17.                       (when (>= k ,n) (return))
  18.                       (let ((k1 (+ k 1)))
  19.                         (when (and (< k1 ,n)
  20.                                    (minusp (funcall comparefun (funcall key (aref A k))
  21.                                                                (funcall key (aref A k1))
  22.                               )    )       )
  23.                           (setq k k1)
  24.                       ) )
  25.                       (when (minusp (funcall comparefun (funcall key (aref A j))
  26.                                                         (funcall key (aref A k))
  27.                             )       )
  28.                         (rotatef (aref A j) (aref A k))
  29.                       )
  30.                       (setq j k)
  31.                   ) )
  32.               ))
  33.       ; Array in Form eines Heap bringen:
  34.       (do ((jj (1- (ash n -1)) (1- jj)))
  35.           ((minusp jj))
  36.         (adjust jj n)
  37.       )
  38.       ; Nacheinander das jeweils verbleibende größte Element (Position 0)
  39.       ; extrahieren, ein anderes Element an Position 0 bringen und dieses
  40.       ; wieder in Heap-Form bringen:
  41.       (let ((jj n))
  42.         (loop
  43.           (decf jj)
  44.           (unless (plusp jj) (return))
  45.           (rotatef (aref A 0) (aref A jj))
  46.           (adjust 0 jj)
  47.       ) )
  48.       (coerce A 'list)
  49. ) ) )
  50.  
  51.